home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / throw.t < prev    next >
Encoding:
Text File  |  1988-05-02  |  7.6 KB  |  201 lines
  1. (herald throw (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; dynamic state manipulation
  27.  
  28. ;;; deficiencies:
  29. ;;;  - there's no way to temporarily "bind" the dynamic state (a la pdl
  30. ;;;    pointer args to eval in maclisp).
  31. ;;;  - there's no proviso for coroutines/multitasking (stack groups).
  32. ;;; these both stem from the assumption rooted fairly deep that changes in
  33. ;;; the "dynamic state" are irreversible.  this will change.
  34.  
  35. ;;; preliminaries:
  36.  
  37. (define-integrable (magic-frame? frame)
  38.   (eq? (extend-header frame) *magic-frame-template*))
  39.  
  40. ;;; state objects are actually the same as magic frames.
  41.  
  42. (define-integrable (magic-frame-state frame) frame)
  43.                                                       
  44. ;;; binding:
  45.  
  46. (define-predicate stack?)
  47.  
  48. (define-handler stack
  49.   (object nil
  50.     ((stack? self) t)
  51.     ((print-type-string self) "Stack")))
  52.   
  53.  
  54. (define (bind-handler wind stuff unwind)
  55.   ;; someday worry about doing things atomically.
  56.   (wind)
  57.   (push-magic-frame unwind stuff wind))
  58.  
  59.  
  60. (define (unwind-protect-handler stuff unwind)
  61.   (push-magic-frame unwind stuff false))
  62.  
  63. (define (bind-internal state stuff)
  64.   (set (process-global task/dynamic-state) state)
  65.   (receive results
  66.            (stuff)
  67.     (perform-unwind state)
  68.     (set (process-global task/dynamic-state) (state-previous state))
  69.     (apply return results)))
  70.  
  71. (define (perform-unwind state)          ; want better name!
  72.   (let ((unwind (state-unwinder state)))
  73.     (set (state-unwinder state)
  74.          (if (eq? unwind throw-out-of-unwind)      ; kludge
  75.              false
  76.              throw-out-of-unwind))
  77.     (unwind)
  78.     (set (state-unwinder state) false)))
  79.  
  80. (define (throw-out-of-unwind)
  81.   (error "attempting to throw out of an unwind or unbind action -~%~
  82.           **~10tdoing (ret) or (reset) will abort the unwind action and~%~
  83.           **~10tproceed with the throw anyhow."))
  84.  
  85. ;;; throwing: one-stack model.
  86.  
  87. ;;; the following is invariant, for now at least:
  88. ;;;  (eq? *dynamic-state* (get-dynamic-state (current-frame)))
  89.  
  90. (lset *the-current-throw-value* nil)          ; el hacko grossness
  91. (lset *the-current-throw-frame* nil)
  92.                                                     
  93. (define-operation (escape-procedure-frame proc))
  94. (define-predicate escape-procedure?)
  95.                                 
  96. (define (*catch proc)
  97.   (let ((cc (current-continuation)))          
  98.     (proc (object (lambda vals (frame-throw cc vals))
  99.             ((print-type-string self) "Escape-procedure")
  100.             ((escape-procedure? self) t)
  101.             ((escape-procedure-frame self) cc)))))
  102.  
  103.          
  104. (define (call-with-current-continuation proc)
  105.   (let* ((sp (descriptor->fixnum (current-continuation)))
  106.          (current-state (process-global task/dynamic-state))
  107.          (base-state (get-base-state current-state))
  108.          (stack (copy-stack sp)))
  109.     (proc (object (lambda vals 
  110.                     (continuation-throw sp stack vals current-state base-state))
  111.             ((print-type-string self) "Upward-continuation")))))
  112.                                                                 
  113. (define (get-base-state state)
  114.   (iterate loop ((state state))
  115.     (let ((prev (state-previous state)))
  116.       (cond ((null? prev) state)
  117.             (else (loop prev))))))
  118.            
  119. ;;; COPY-STACK The make-pointer is to pretend that the
  120. ;;; stack has a header at the top
  121.  
  122. (define (copy-stack sp)
  123.   (let* ((size (fx+ (fx- (descriptor->fixnum (process-global task/stack)) sp) 1))
  124.          (stack (make-vector-extend header/stack 
  125.                                     (enforce acceptable-vector-size? size)
  126.                                     size)))
  127.     (disable-interrupts)
  128.     (%copy-extend stack 
  129.                   (make-pointer (gc-extend->pair (gc-extend->pair sp)) -2)
  130.                   size)
  131.     (enable-interrupts)
  132.     stack))
  133.  
  134. (define (continuation-throw sp stack vals k-state base-state)
  135.   (cond ((stack? stack)
  136.          (let ((a (swap *the-current-throw-value* vals))
  137.                (b (swap *the-current-throw-frame* stack)))
  138.            (unwind-to-top)
  139.            (set *the-current-throw-frame* b)
  140.            (set *the-current-throw-value* a)
  141.            (set (process-global task/dynamic-state) k-state)
  142.            (invoke-continuation sp stack vals base-state k-state)))
  143.         (else
  144.          (error "throwing ~s to bad continuation ~s" vals stack))))
  145.                                   
  146.                              
  147. (define (rewind-state-and-continue from to vals)
  148.   (do ((state from (state-next state)))
  149.       ((eq? state to) 
  150.        ((state-winder state))
  151.        (apply return vals))
  152.     ((state-winder state))))
  153.  
  154.  
  155. (define (frame-throw frame vals)
  156.   (cond ((reasonable-frame? frame)
  157.          (let ((a (swap *the-current-throw-value* vals))
  158.                (b (swap *the-current-throw-frame* frame))
  159.                 (to-state (get-dynamic-state frame)))
  160.           (unwind-to-state to-state)
  161.           (set *the-current-throw-frame* b)
  162.           (set *the-current-throw-value* a)
  163.           (set (process-global task/dynamic-state) to-state)
  164.           (invoke-stack-continuation frame vals)))
  165.         (else
  166.          (frame-throw (error "invalid frame - (~s ~s ~s)"
  167.                              'frame-throw frame vals)
  168.                       vals))))
  169.  
  170. (define (unwind-to-state to-state)
  171.   (iterate loop ((state (process-global task/dynamic-state)))
  172.     (cond ((eq? state to-state) 'done)
  173.           ((null? state)
  174.            (warning "lost big while changing dynamic context to ~s!~
  175.                     ~%;**     attempting to do the throw anyhow...~%"
  176.                     to-state))
  177.           (else
  178.  
  179.            (perform-unwind state)
  180.            (loop (state-previous state))))))
  181.  
  182. (define (unwind-to-top)
  183.   (iterate loop ((state (process-global task/dynamic-state)))
  184.     (cond ((eq? state nil))
  185.           ((eq? (state-winder state) false)
  186.        (loop (state-previous state)))
  187.           (else
  188.            (perform-unwind state)
  189.            (loop (state-previous state))))))
  190.  
  191. (define (get-dynamic-state frame)
  192.   (cond ((null? frame) '())
  193.         ((magic-frame? frame) (magic-frame-state frame))
  194.         (else (get-dynamic-state (frame-previous frame)))))
  195.  
  196. (define (reasonable-frame? frame)
  197.   (and (closure? frame)                   ; robust?
  198.        (let ((frame (descriptor->fixnum frame)))
  199.          (and (fx> frame (stack-pointer))
  200.               (fx<= frame (process-global task/stack))))))
  201.